home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / GAUGE.ARJ / OBGAUGE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-14  |  14KB  |  505 lines
  1. {$N+}
  2. {$R OBGAUGE}
  3.  
  4. program OBGauge;
  5. uses
  6.   WObjects, WinTypes, WinProcs, WinDOS, Strings, Utils;
  7.  
  8. const
  9.   AppName : PChar = 'OBGAUGE';
  10.  
  11.   ids_FSpace = 101;    (* Free Disk Space Static Control *)
  12.   ids_TSpace = 102;    (* Total Disk Space Static Control *)
  13.   ids_FMem   = 103;    (* Free Memory Static Control *)
  14.   ids_FRes   = 104;    (* Free System Resources Static Control *)
  15.   ids_Date   = 105;    (* Date Static Control *)
  16.   ids_Time   = 106;    (* Time Static Control *)
  17.  
  18.   idc_Drives = 107;    (* Drive Selection Combo Box *)
  19.  
  20.   idr_DSpace = 108;    (* Disk Space Radio Button *)
  21.   idr_Memory = 109;    (* Memory Radio Button *)
  22.   idr_SysRes = 110;    (* System Resources Radio Button *)
  23.   idr_Time   = 111;    (* Time Radio Button *)
  24.   idr_Date   = 112;    (* Date Radio Button *)
  25.  
  26.   ids_Icon   = 125;    (* Icon in window! *)
  27.  
  28.   cm_About   = 200;
  29.  
  30.   id_Timer   = 1;
  31.  
  32.   tDiskRect : TRect = (left : 125; top : 15; right : 375; bottom : 35);
  33.  
  34. type
  35.   TGaugeApp = object(TApplication)
  36.        procedure InitMainWindow; virtual;
  37.   end;
  38.  
  39.   PGaugeDialog = ^TGaugeDialog;
  40.   TGaugeDialog = object(TDlgWindow)
  41.     DrivesAdded : Boolean;
  42.     redBrush,
  43.     whiteBrush : HBrush;
  44.     avDiskRect : TRect;
  45.     curChoice,
  46.     lastDrive,
  47.     curDrive   : Integer;
  48.     sfSpace  : PStatic;
  49.     stSpace  : PStatic;
  50.     sfMemory : PStatic;
  51.     sfRes    : PStatic;
  52.     sfTime   : PStatic;
  53.     sfDate   : PStatic;
  54.     lbDrives : PListBox;
  55.     rbDSpace : PRadioButton;
  56.     rbMemory : PRadioButton;
  57.     rbSysRes : PRadioButton;
  58.     rbTime   : PRadioButton;
  59.     rbDate   : PRadioButton;
  60.  
  61.     constructor Init(AParent : PWindowsObject; AName : Pchar);
  62.     destructor Done; virtual;
  63.     function GetClassName : PChar; virtual;
  64.     procedure GetWindowClass(var AWndClass : TWndClass); virtual;
  65.     procedure WMDestroy(var Msg : TMessage); virtual wm_First + wm_Destroy;
  66.     procedure WMCtlClr(var Msg : TMessage); virtual wm_First + wm_CtlColor;
  67.     procedure WMTimer(var Msg : TMessage); virtual wm_First + wm_Timer;
  68.     procedure CMAbout(var Msg : TMessage);
  69.     procedure WMSysCommand(var Msg : TMessage);
  70.       virtual wm_First + wm_SysCommand;
  71.     procedure SetUpWindow; virtual;
  72.     procedure InitControls;
  73.     procedure UpdateControls(aDC : HDC);
  74.     procedure WMPaint(var Msg : TMessage);
  75.       virtual wm_First + wm_Paint;
  76.     procedure DrawDrive(aDC : HDC; Rect : TRect);
  77.     procedure DrawMemory(aDC : HDC; Rect : TRect);
  78.     procedure DrawSysRes(aDC : HDC; Rect : TRect);
  79.     procedure DrawTime(aDC : HDC; Rect : TRect);
  80.     procedure DrawDate(aDC : HDC; Rect : TRect);
  81.     procedure IconPaint(aDC : HDC);
  82.     procedure Ok(var Msg : TMessage); virtual id_First + id_Ok;
  83.     procedure WMCommand(var Msg : TMessage); virtual wm_First + wm_Command;
  84.     procedure idDSpace(var Msg : TMessage); virtual id_First + idr_DSpace;
  85.     procedure idMemory(var Msg : TMessage); virtual id_First + idr_Memory;
  86.     procedure idSysRes(var Msg : TMessage); virtual id_First + idr_SysRes;
  87.     procedure idTime(var Msg : TMessage); virtual id_First + idr_Time;
  88.     procedure idDate(var Msg : TMessage); virtual id_First + idr_Date;
  89.   end;
  90.  
  91.  
  92. constructor TGaugeDialog.Init(AParent : PWindowsObject; AName : Pchar);
  93.   begin
  94.     TDlgWindow.Init(AParent, AName);
  95.     InitControls;
  96.     DrivesAdded := False;
  97.     curChoice := idr_DSpace;
  98.   end;
  99.  
  100. destructor TGaugeDialog.Done;
  101.   begin
  102.     DeleteObject(whiteBrush);
  103.     DeleteObject(redBrush);
  104.     TDlgWindow.Done;
  105.   end;
  106.  
  107.  
  108. procedure TGaugeDialog.Ok(var Msg : TMessage);
  109.   begin
  110.     SendMessage(HWindow, wm_SysCommand, sc_Minimize, 0);
  111.   end;
  112.  
  113. procedure TGaugeDialog.WMCommand(var Msg : TMessage);
  114.   var
  115.     aDC : HDC;
  116.   begin
  117.     if (Msg.WParam = idc_Drives) and (Msg.LParamHi = lbn_SelChange) then
  118.       begin
  119.         curDrive := lbDrives^.GetSelIndex;
  120.         aDC := GetDC(Msg.Receiver);
  121.         UpdateControls(aDC);
  122.         ReleaseDC(Msg.Receiver, aDC);
  123.       end
  124.     else
  125.       TWindowsObject.WMCommand(Msg);
  126.   end;
  127.  
  128. function TGaugeDialog.GetClassName : PChar;
  129.   begin
  130.     GetClassName := AppName;
  131.   end;
  132.  
  133. procedure TGaugeDialog.GetWindowClass(var AWndClass : TWndClass);
  134.   begin
  135.     TDlgWindow.GetWindowClass(AWndClass);
  136.     AWndClass.hIcon := 0;
  137.   end;
  138.  
  139. procedure TGaugeDialog.SetUpWindow;
  140.   var
  141.     curDir   : PChar;
  142.     dTotal,
  143.     avSpace  : LongInt;
  144.     Ratio    : Single;
  145.     theMem   : String;
  146.     theRes   : LongInt;
  147.     i        : Integer;
  148.     hSysMenu : HMenu;
  149.     theDC    : HDC;
  150.   begin
  151.     TDlgWindow.SetUpWindow;
  152.     hSysMenu := GetSystemMenu(HWindow, False);
  153.     AppendMenu(hSysMenu, mf_Separator, 0, Nil);
  154.     AppendMenu(hSysMenu, mf_String, cm_About, 'About...');
  155.     EnableMenuItem(hSysMenu, 2, mf_byPosition or mf_Grayed);
  156.     EnableMenuItem(hSysMenu, 4, mf_byPosition or mf_Grayed);
  157.     whiteBrush := CreateSolidBrush(RGB(255, 255, 255));
  158.     redBrush := CreateSolidBrush(RGB(255, 0, 0));
  159.  
  160.     SetTimer(HWindow, id_Timer, 5000, Nil);
  161.  
  162.     GetMem(curDir, fsDirectory);
  163.     GetCurDir(curDir, 0);
  164.     curDrive := Ord(curDir[0]) - 67;
  165.     FreeMem(curDir, fsDirectory);
  166.  
  167.     SetInternational;
  168.     (* First, determine the available drives, skipping A: & B: *)
  169.     lastDrive := GetDriveInfo;
  170.     theDC := GetDC(HWindow);
  171.     UpdateControls(theDC);
  172.     ReleaseDC(HWindow, theDC);
  173.   end;
  174.  
  175. procedure TGaugeDialog.UpdateControls(aDC : HDC);
  176.   var
  177.     curDir : PChar;
  178.     oldBrush : HBrush;
  179.     dTotal,
  180.     avSpace  : LongInt;
  181.     Ratio,
  182.     temp     : Single;
  183.     theMem   : String;
  184.     theRes   : LongInt;
  185.     i        : Integer;
  186.     tInt     : LongInt;
  187.   begin
  188.     GetAvail(curDrive, avDrives[curDrive].dTotal, avSpace, ratio);
  189.  
  190.     with tDiskRect do
  191.       Rectangle(aDC, left, top, right, bottom);
  192.  
  193.     with avDiskRect do begin
  194.       left := tDiskRect.left;
  195.       top := tDiskRect.top;
  196.       bottom := tDiskRect.bottom;
  197.       tInt := tDiskRect.right - tDiskRect.left;
  198.       temp := Single(tInt) * Ratio;
  199.       right := LongInt(temp) + left;
  200.     end;
  201.  
  202.     oldBrush := SelectObject(aDC, redBrush);
  203.  
  204.     with avDiskRect do
  205.       Rectangle(aDC, left, top, right, bottom);
  206.  
  207.     theMem := GetFreeMemory;
  208.     theRes := GetFreeResources;
  209.     if (not DrivesAdded) then begin
  210.       DrivesAdded := True;
  211.       for i := 0 to lastDrive do
  212.         lbDrives^.AddString(avDrives[i].dLetter);
  213.     end;
  214.  
  215.     GetMem(curDir, 25);
  216.  
  217.     wvsprintf(curDir, '%lu Mb', avSpace);
  218.     sfSpace^.SetText(curDir);
  219.  
  220.     wvsprintf(curDir, '%lu Mb', avDrives[curDrive].dTotal);
  221.     stSpace^.SetText(curDir);
  222.  
  223.     StrPCopy(curDir, theMem);
  224.     sfMemory^.SetText(curDir);
  225.  
  226.     wvsprintf(curDir, '%2u%% User   %2u%% GDI', theRes);
  227.     sfRes^.SetText(curDir);
  228.  
  229.     FreeMem(curDir, 25);
  230.  
  231.     GetCurDate(curDir);
  232.     sfDate^.SetText(curDir);
  233.     FreeMem(curDir, StrLen(curDir) + 1);
  234.  
  235.     GetCurTime(curDir);
  236.     sfTime^.SetText(curDir);
  237.     FreeMem(curDir, StrLen(curDir) + 1);
  238.  
  239.     lbDrives^.SetSelIndex(curDrive);
  240.   end;
  241.  
  242.  
  243. procedure TGaugeDialog.DrawDrive(aDC : HDC; Rect : TRect);
  244.   var
  245.     aRect    : TRect;
  246.     oldBrush : HBrush;
  247.     tInt     : LongInt;
  248.     temp     : Single;
  249.     oldMode  : Integer;
  250.     oldAlign : Word;
  251.     avSpace  : LongInt;
  252.     dRatio   : Single;
  253.   begin
  254.     GetAvail(curDrive, avDrives[curDrive].dTotal, avSpace, dRatio);
  255.  
  256.     with aRect do begin
  257.       left := Rect.left;
  258.       right := Rect.right;
  259.       top := Rect.top;
  260.       tInt := Rect.bottom;
  261.       temp := Single(tInt) * dRatio;
  262.       bottom := LongInt(temp);
  263.     end;
  264.     
  265.     oldBrush := SelectObject(aDC, redBrush);
  266.     with aRect do
  267.        Rectangle(aDC, left, top, right, bottom);
  268.     SelectObject(aDC, oldBrush);
  269.  
  270.     oldMode := SetBkMode(aDC, Transparent);
  271.     TextOut(aDC, Rect.left + 10, Rect.top + 10, avDrives[curDrive].dLetter,
  272.             strlen(avDrives[curDrive].dLetter));
  273.     SetBkMode(aDC, oldMode);
  274.   end;
  275.  
  276. procedure TGaugeDialog.DrawMemory(aDC : HDC; Rect : TRect);
  277.   var
  278.     avMem : PChar;
  279.     oldMode : Integer;
  280.   begin
  281.     GetMem(avMem, 20);
  282.     StrPCopy(avMem, GetFreeMemory);   (* get memory *)
  283.  
  284.     oldMode := SetBkMode(aDC, Transparent);
  285.     DrawText(aDC, avMem, strlen(avMem), Rect, dt_WordBreak);
  286.     FreeMem(avMem, 20);
  287.     SetBkMode(aDC, oldMode);
  288.   end;
  289.  
  290. procedure TGaugeDialog.DrawSysRes(aDC : HDC; Rect : TRect);
  291.   var
  292.     lRes    : LongInt;
  293.     tWord   : Word;
  294.     avResource : PChar;
  295.     oldMode : Integer;
  296.   begin
  297.     lRes := GetFreeResources;  (* get free resources *)
  298.     if (LoWord(lRes) < HiWord(lRes)) then
  299.       tWord := LoWord(lRes)
  300.     else
  301.       tWord := HiWord(lRes);
  302.     GetMem(avResource, 25);
  303.     wvsprintf(avResource, '%2u%% Avail', tWord);
  304.  
  305.     oldMode := SetBkMode(aDC, Transparent);
  306.     DrawText(aDC, avResource, strlen(avResource), Rect, dt_WordBreak);
  307.     FreeMem(avResource, 25);
  308.     SetBkMode(aDC, oldMode);
  309.   end;
  310.  
  311. procedure TGaugeDialog.DrawTime(aDC : HDC; Rect : TRect);
  312.   var
  313.     theTime : PChar;
  314.     oldMode : Integer;
  315.   begin
  316.     GetCurTime(theTime);
  317.  
  318.     oldMode := SetBkMode(aDC, Transparent);
  319.     DrawText(aDC, theTime, strlen(theTime), Rect, dt_WordBreak);
  320.     FreeMem(theTime, StrLen(theTime) + 1);
  321.     SetBkMode(aDC, oldMode);
  322.   end;
  323.  
  324. procedure TGaugeDialog.DrawDate(aDC : HDC; Rect : TRect);
  325.   var
  326.     theDate : PChar;
  327.     oldMode : Integer;
  328.   begin
  329.     GetCurDate(theDate);
  330.     oldMode := SetBkMode(aDC, Transparent);
  331.     DrawText(aDC, theDate, strlen(theDate), Rect, dt_WordBreak);
  332.     FreeMem(theDate, StrLen(theDate) + 1);
  333.     SetBkMode(aDC, oldMode);
  334.   end;
  335.  
  336.  
  337. procedure TGaugeDialog.IconPaint(aDC : HDC);
  338.   var
  339.     theRect  : TRect;
  340.     oldBrush : HBrush;
  341.   begin
  342.     GetClientRect(HWindow, theRect);
  343.     oldBrush := SelectObject(aDC, whiteBrush);
  344.  
  345.     with theRect do
  346.       Rectangle(aDC, left, top, right, bottom);
  347.     SelectObject(aDC, oldBrush);
  348.  
  349.     case curChoice of
  350.       idr_DSpace : DrawDrive(aDC, theRect);
  351.       idr_Memory : DrawMemory(aDC, theRect);
  352.       idr_SysRes : DrawSysRes(aDC, theRect);
  353.       idr_Time   : DrawTime(aDC, theRect);
  354.       idr_Date   : DrawDate(aDC, theRect);
  355.     end;
  356.   end;
  357.  
  358.  
  359. procedure TGaugeDialog.InitControls;
  360.   begin
  361.     sfSpace  := New(PStatic, InitResource(@Self, ids_FSpace, 20));
  362.     stSpace  := New(PStatic, InitResource(@Self, ids_TSpace, 20));
  363.     sfMemory := New(PStatic, InitResource(@Self, ids_FMem, 10));
  364.     sfRes    := New(PStatic, InitResource(@Self, ids_FRes, 25));
  365.     sfTime   := New(PStatic, InitResource(@Self, ids_Time, 15));
  366.     sfDate   := New(PStatic, InitResource(@Self, ids_Date, 15));
  367.     lbDrives := New(PListBox, InitResource(@Self, idc_Drives));
  368.  
  369.     rbDSpace := New(PRadioButton, InitResource(@Self, idr_DSpace));
  370.     rbMemory := New(PRadioButton, InitResource(@Self, idr_Memory));
  371.     rbSysRes := New(PRadioButton, InitResource(@Self, idr_SysRes));
  372.     rbTime   := New(PRadioButton, InitResource(@Self, idr_Time));
  373.     rbDate   := New(PRadioButton, InitResource(@Self, idr_Date));
  374.   end;
  375.  
  376.  
  377. procedure TGaugeDialog.CMAbout(var Msg : TMessage);
  378.   var
  379.     Dialog : TDialog;
  380.   begin
  381.     Dialog.Init(@Self, 'AboutBox');
  382.     Dialog.Execute;
  383.     Dialog.Done;
  384.   end;
  385.  
  386. procedure TGaugeDialog.WMSysCommand(var Msg : TMessage);
  387.   begin
  388.     if Msg.WParam = cm_About then
  389.       CMAbout(Msg)
  390.     else
  391.       DefWndProc(Msg);
  392.   end;
  393.  
  394. procedure TGaugeDialog.WMDestroy(var Msg : TMessage);
  395.   begin
  396.     KillTimer(HWindow, id_Timer);
  397.     TDlgWindow.WMDestroy(Msg);
  398.   end;
  399.  
  400. procedure TGaugeDialog.WMTimer(var Msg : TMessage);
  401.   var
  402.     theDC : HDC;
  403.   begin
  404.     if IsIconic(HWindow) then
  405.       InvalidateRect(HWindow, Nil, True)
  406.     else begin
  407.       theDC := GetDC(HWindow);
  408.       UpdateControls(theDC);
  409.       ReleaseDC(HWindow, theDC);
  410.     end;
  411.   end;
  412.  
  413. procedure TGaugeDialog.WMCtlClr(var Msg : TMessage);
  414.   begin
  415.     if (GetDlgCtrlID(Msg.LParamLo) = ids_FSpace) then
  416.       if (Msg.LParamHi = ctlcolor_Static) then begin
  417.         SetBkColor(Msg.WParam, RGB(255, 0, 0));
  418.         SetTextColor(Msg.WParam, RGB(255, 255, 255));
  419.       end;
  420.   end;
  421.  
  422. procedure TGaugeDialog.WMPaint(var Msg : TMessage);
  423.   var
  424.     PaintDC : HDC;
  425.     PS      : TPaintStruct;
  426.   begin
  427.     PaintDC := BeginPaint(Msg.Receiver, PS);
  428.     if IsIconic(HWindow) then
  429.       begin
  430.         IconPaint(PaintDC)
  431.       end
  432.     else
  433.       UpdateControls(PaintDC);
  434.  
  435.     EndPaint(Msg.Receiver, PS);
  436.   end;
  437.  
  438. procedure TGaugeDialog.idDSpace(var Msg : TMessage);
  439.   begin
  440.     rbDSpace^.Check;
  441.     rbMemory^.UnCheck;
  442.     rbSysRes^.UnCheck;
  443.     rbTime^.UnCheck;
  444.     rbDate^.UnCheck;
  445.     curChoice := idr_DSpace;
  446.   end;
  447.  
  448. procedure TGaugeDialog.idMemory(var Msg : TMessage);
  449.   begin
  450.     rbDSpace^.UnCheck;
  451.     rbMemory^.Check;
  452.     rbSysRes^.UnCheck;
  453.     rbTime^.UnCheck;
  454.     rbDate^.UnCheck;
  455.     curChoice := idr_Memory;
  456.   end;
  457.  
  458. procedure TGaugeDialog.idSysRes(var Msg : TMessage);
  459.   begin
  460.     rbDSpace^.UnCheck;
  461.     rbMemory^.UnCheck;
  462.     rbSysRes^.Check;
  463.     rbTime^.UnCheck;
  464.     rbDate^.UnCheck;
  465.     curChoice := idr_SysRes;
  466.   end;
  467.  
  468. procedure TGaugeDialog.idTime(var Msg : TMessage);
  469.   begin
  470.     rbDSpace^.UnCheck;
  471.     rbMemory^.UnCheck;
  472.     rbSysRes^.UnCheck;
  473.     rbTime^.Check;
  474.     rbDate^.UnCheck;
  475.     curChoice := idr_Time;
  476.   end;
  477.  
  478. procedure TGaugeDialog.idDate(var Msg : TMessage);
  479.   begin
  480.     rbDSpace^.UnCheck;
  481.     rbMemory^.UnCheck;
  482.     rbSysRes^.UnCheck;
  483.     rbTime^.UnCheck;
  484.     rbDate^.Check;
  485.     curChoice := idr_Date;
  486.   end;
  487.  
  488. procedure TGaugeApp.InitMainWindow;
  489.   var
  490.     aMenu : HMenu;
  491.   begin
  492.     MainWindow := New(PGaugeDialog, Init(Nil, AppName));
  493.   end;
  494.  
  495. var
  496.   MyApp : TGaugeApp;
  497.  
  498. begin
  499.   MyApp.Init(AppName);
  500.   MyApp.Run;
  501.   MyApp.Done;
  502. end.
  503.  
  504.  
  505.